home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / dfun.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  33.2 KB  |  904 lines

  1. ;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. #|
  31.  
  32. This implementation of method lookup was redone in early August of 89.
  33.  
  34. It has the following properties:
  35.  
  36.  - It's modularity makes it easy to modify the actual caching algorithm.
  37.    The caching algorithm is almost completely separated into the files
  38.    cache.lisp and dlap.lisp.  This file just contains the various uses
  39.    of it. There will be more tuning as we get more results from Luis'
  40.    measurements of caching behavior.
  41.  
  42.  - The metacircularity issues have been dealt with properly.  All of
  43.    PCL now grounds out properly.  Moreover, it is now possible to have
  44.    metaobject classes which are themselves not instances of standard
  45.    metaobject classes.
  46.  
  47. ** Modularity of the code **
  48.  
  49. The actual caching algorithm is isolated in a modest number of functions.
  50. The code which generates cache lookup code is all found in cache.lisp and
  51. dlap.lisp.  Certain non-wrapper-caching special cases are in this file.
  52.  
  53.  
  54. ** Handling the metacircularity **
  55.  
  56. In CLOS, method lookup is the potential source of infinite metacircular
  57. regress.  The metaobject protocol specification gives us wide flexibility
  58. in how to address this problem.  PCL uses a technique which handles the
  59. problem not only for the metacircular language described in Chapter 3, but
  60. also for the PCL protocol which includes additional generic functions
  61. which control more aspects of the CLOS implementation.
  62.  
  63. The source of the metacircular regress can be seen in a number of ways.
  64. One is that the specified method lookup protocol must, as part of doing
  65. the method lookup (or at least the cache miss case), itself call generic
  66. functions.  It is easy to see that if the method lookup for a generic
  67. function ends up calling that same generic function there can be trouble.
  68.  
  69. Fortunately, there is an easy solution at hand.  The solution is based on 
  70. the restriction that portable code cannot change the class of a specified
  71. metaobject.  This restriction implies that for specified generic functions,
  72. the method lookup protocol they follow is fixed.  
  73.  
  74. More precisely, for such specified generic functions, most generic functions
  75. that are called during their own method lookup will not run portable methods. 
  76. This allows the implementation to usurp the actual generic function call in
  77. this case.  In short, method lookup of a standard generic function, in the
  78. case where the only applicable methods are themselves standard doesn't
  79. have to do any method lookup to implement itself.
  80.  
  81. And so, we are saved.
  82.  
  83. |#
  84.  
  85.  
  86.  
  87. ;An alist in which each entry is of the form :
  88. ;  (<generator> . (<subentry> ...))
  89. ;Each subentry is of the form:
  90. ;  (<args> <constructor> <system>)
  91. (defvar *dfun-constructors* ())            
  92.  
  93. ;If this is NIL, then the whole mechanism
  94. ;for caching dfun constructors is turned
  95. ;off.  The only time that makes sense is
  96. ;when debugging LAP code. 
  97. (defvar *enable-dfun-constructor-caching* t)    
  98.  
  99. (defun show-dfun-constructors ()
  100.   (format t "~&DFUN constructor caching is ~A." 
  101.       (if *enable-dfun-constructor-caching*
  102.           "enabled" "disabled"))
  103.   (dolist (generator-entry *dfun-constructors*)
  104.     (dolist (args-entry (cdr generator-entry))
  105.       (format t "~&~S ~S"
  106.           (cons (car generator-entry) (caar args-entry))
  107.           (caddr args-entry)))))
  108.  
  109.  
  110. (declaim (ftype (function (T &rest T) real-function) get-dfun-constructor))
  111. (defun get-dfun-constructor (generator &rest args)
  112.   (let* ((generator-entry (assq generator *dfun-constructors*))
  113.      (args-entry (assoc args (cdr generator-entry) :test #'equal)))
  114.     (if (null *enable-dfun-constructor-caching*)
  115.     (apply-function (symbol-function generator) args)
  116.     (or (cadr args-entry)
  117.         (let ((new (apply-function (symbol-function generator) args)))
  118.           (if generator-entry
  119.           (push (list (copy-list args) new nil) (cdr generator-entry))
  120.           (push (list generator (list (copy-list args) new nil)) *dfun-constructors*))
  121.           new)))))
  122.  
  123. (defun load-precompiled-dfun-constructor (generator args system constructor)
  124.   (let* ((generator-entry (assq generator *dfun-constructors*))
  125.      (args-entry (assoc args (cdr generator-entry) :test #'equal)))
  126.     (unless args-entry
  127.       (if generator-entry
  128.       (push (list args constructor system) (cdr generator-entry))
  129.       (push (list generator (list args constructor system)) *dfun-constructors*)))))
  130.  
  131. (defmacro precompile-dfun-constructors (&optional system)
  132.   #+excl (declare (ignore system))
  133.   #+excl ()
  134.   #-excl
  135.   (let ((*precompiling-lap* t))
  136.     `(progn
  137.        ,@(gathering1 (collecting)
  138.        (dolist (generator-entry *dfun-constructors*)
  139.          (dolist (args-entry (cdr generator-entry))
  140.            (when (or (null (caddr args-entry))
  141.              (eq (caddr args-entry) system))
  142.          (when system (setf (caddr args-entry) system))
  143.          (multiple-value-bind (closure-variables arguments 
  144.                              iregs vregs fvregs tregs lap)
  145.              (apply-function (symbol-function (car generator-entry))
  146.                                      (car args-entry))
  147.            (gather1
  148.              (make-top-level-form `(precompile-dfun-constructor 
  149.                         ,(car generator-entry))
  150.                       '(load)
  151.                `(load-precompiled-dfun-constructor
  152.               ',(car generator-entry)
  153.               ',(car args-entry)
  154.               ',system
  155.               (precompile-lap-closure-generator ,closure-variables
  156.                                 ,arguments
  157.                                 ,iregs
  158.                                 ,vregs
  159.                                                 ,fvregs
  160.                                 ,tregs
  161.                                 ,lap))))))))))))
  162.  
  163.  
  164. ;;;
  165. ;;; When all the methods of a generic function are automatically generated
  166. ;;; reader or writer methods a number of special optimizations are possible.
  167. ;;; These are important because of the large number of generic functions of
  168. ;;; this type.
  169. ;;;
  170. ;;; There are a number of cases:
  171. ;;;
  172. ;;;   ONE-CLASS-ACCESSOR
  173. ;;;     In this case, the accessor generic function has only been called
  174. ;;;     with one class of argument.  There is no cache vector, the wrapper
  175. ;;;     of the one class, and the slot index are stored directly as closure
  176. ;;;     variables of the discriminating function.  This case can convert to
  177. ;;;     either of the next kind.
  178. ;;;
  179. ;;;   TWO-CLASS-ACCESSOR
  180. ;;;     Like above, but two classes.  This is common enough to do specially.
  181. ;;;     There is no cache vector.  The two classes are stored a separate
  182. ;;;     closure variables.
  183. ;;;
  184. ;;;   ONE-INDEX-ACCESSOR
  185. ;;;     In this case, the accessor generic function has seen more than one
  186. ;;;     class of argument, but the index of the slot is the same for all
  187. ;;;     the classes that have been seen.  A cache vector is used to store
  188. ;;;     the wrappers that have been seen, the slot index is stored directly
  189. ;;;     as a closure variable of the discriminating function.  This case
  190. ;;;     can convert to the next kind.
  191. ;;;
  192. ;;;   N-N-ACCESSOR
  193. ;;;     This is the most general case.  In this case, the accessor generic
  194. ;;;     function has seen more than one class of argument and more than one
  195. ;;;     slot index.  A cache vector stores the wrappers and corresponding
  196. ;;;     slot indexes.  Because each cache line is more than one element
  197. ;;;     long, a cache lock count is used.
  198. ;;;
  199. (defstruct (dfun-info
  200.          (:constructor nil)
  201.          (:print-function print-dfun-info))
  202.   (cache nil))
  203.  
  204. (defun print-dfun-info (dfun-info stream depth)
  205.   (declare (ignore depth) (stream stream))
  206.   (printing-random-thing (dfun-info stream)
  207.     (format stream "~A" (type-of dfun-info))))
  208.  
  209. (defstruct (no-methods
  210.          (:constructor no-methods-dfun-info ())
  211.          (:include dfun-info)))
  212.  
  213. (defstruct (initial-dispatch
  214.          (:constructor initial-dispatch-dfun-info ())
  215.          (:include dfun-info)))
  216.  
  217. (defstruct (dispatch
  218.          (:constructor dispatch-dfun-info ())
  219.          (:include dfun-info)))
  220.  
  221. (defstruct (default-method-only
  222.          (:constructor default-method-only-dfun-info ())
  223.          (:include dfun-info)))
  224.  
  225. ;without caching:
  226. ;  dispatch one-class two-class default-method-only
  227.  
  228. ;with caching:
  229. ;  one-index n-n checking caching
  230.  
  231. ;accessor:
  232. ;  one-class two-class one-index n-n
  233. (defstruct (accessor-dfun-info
  234.          (:constructor nil)
  235.          (:include dfun-info))
  236.   accessor-type) ; (member reader writer)
  237.  
  238. (defmacro dfun-info-accessor-type (di)
  239.   `(accessor-dfun-info-accessor-type ,di))
  240.  
  241. (defstruct (one-index-dfun-info
  242.          (:constructor nil)
  243.          (:include accessor-dfun-info))
  244.   index)
  245.  
  246. (defmacro dfun-info-index (di)
  247.   `(one-index-dfun-info-index ,di))
  248.  
  249. (defstruct (n-n
  250.          (:constructor n-n-dfun-info (accessor-type cache))
  251.          (:include accessor-dfun-info)))
  252.  
  253. (defstruct (one-class
  254.          (:constructor one-class-dfun-info (accessor-type index wrapper0))
  255.          (:include one-index-dfun-info))
  256.   wrapper0)
  257.  
  258. (defmacro dfun-info-wrapper0 (di)
  259.   `(one-class-wrapper0 ,di))
  260.  
  261. (defstruct (two-class
  262.          (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
  263.          (:include one-class))
  264.   wrapper1)
  265.  
  266. (defmacro dfun-info-wrapper1 (di)
  267.   `(two-class-wrapper1 ,di))
  268.  
  269. (defstruct (one-index
  270.          (:constructor one-index-dfun-info
  271.                (accessor-type index cache))
  272.          (:include one-index-dfun-info)))         
  273.  
  274. (defstruct (checking
  275.          (:constructor checking-dfun-info (function cache))
  276.          (:include dfun-info))
  277.   function)
  278.  
  279. (defmacro dfun-info-function (di)
  280.   `(checking-function ,di))
  281.  
  282. (defstruct (caching
  283.          (:constructor caching-dfun-info (cache))
  284.          (:include dfun-info)))
  285.  
  286. (defstruct (constant-value
  287.          (:constructor constant-value-dfun-info (cache))
  288.          (:include dfun-info)))
  289.  
  290. (defmacro dfun-update (generic-function function &rest args)
  291.   `(multiple-value-bind (dfun cache info)
  292.        (funcall-function ,function ,generic-function ,@args)
  293.      (update-dfun ,generic-function dfun cache info)))
  294.  
  295. (defun accessor-miss-function (gf dfun-info)
  296.   (ecase (dfun-info-accessor-type dfun-info)
  297.     (reader
  298.       #'(lambda (arg)
  299.        (declare (pcl-fast-call))
  300.        (accessor-miss gf nil arg dfun-info)))
  301.     (writer
  302.      #'(lambda (new arg)
  303.      (declare (pcl-fast-call))
  304.      (accessor-miss gf new arg dfun-info)))))
  305.  
  306.  
  307. (declaim (ftype (function (T T T T) (values function null T))
  308.         make-one-class-accessor-dfun))
  309. (declaim (ftype (function (T T T T T) (values function null T))
  310.         make-two-class-accessor-dfun))
  311. (declaim (ftype (function (T T T &optional T) (values function cache T))
  312.         make-one-index-accessor-dfun))
  313. (declaim (ftype (function (T T T T) (values function cache T))
  314.         make-final-one-index-accessor-dfun))
  315. (declaim (ftype (function (T T &optional T) (values function cache T))
  316.         make-n-n-accessor-dfun))
  317. (declaim (ftype (function (T T T) (values function cache T))
  318.         make-final-n-n-accessor-dfun))
  319. (declaim (ftype (function (T T &optional T) (values function (or cache null) T))
  320.         make-checking-dfun))
  321. (declaim (ftype (function (T T T T) (values function (or cache null) T))
  322.         make-final-checking-dfun))
  323. (declaim (ftype (function (T &optional T) (values function (or cache null) T))
  324.         make-caching-dfun))
  325. (declaim (ftype (function (T T T) (values function (or cache null) T))
  326.         make-final-caching-dfun))
  327. (declaim (ftype (function (T &optional T) (values function cache T))
  328.         make-constant-value-dfun))
  329. (declaim (ftype (function (T T T) (values function cache T))
  330.         make-final-constant-value-dfun))
  331. (declaim (ftype (function (T) (values function null T))
  332.         make-dispatch-dfun
  333.         make-final-dispatch-dfun))
  334. (declaim (ftype (function (T &optional T) (values function (or cache null) T))
  335.         make-final-dfun-internal))
  336.  
  337. (declaim (ftype (function (T) boolean)
  338.         use-caching-dfun-p
  339.         use-dispatch-dfun-p))
  340.  
  341. ;;;
  342. ;;; ONE-CLASS-ACCESSOR
  343. ;;;
  344. (declaim (ftype (function (T T T T) (values function null T))
  345.         make-one-class-accessor-dfun))
  346. (defun make-one-class-accessor-dfun (gf type wrapper index)
  347.   (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
  348.     (dfun-info (one-class-dfun-info type index wrapper)))
  349.     (values
  350.      (funcall (get-dfun-constructor emit (consp index))
  351.           wrapper index
  352.           (accessor-miss-function gf dfun-info))
  353.      nil
  354.      dfun-info)))
  355.  
  356. ;;;
  357. ;;; TWO-CLASS-ACCESSOR
  358. ;;;
  359. (declaim (ftype (function (T T T T T) (values function null T))
  360.         make-two-class-accessor-dfun))
  361. (defun make-two-class-accessor-dfun (gf type w0 w1 index)
  362.   (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
  363.     (dfun-info (two-class-dfun-info type index w0 w1)))
  364.     (values
  365.      (funcall (get-dfun-constructor emit (consp index))
  366.           w0 w1 index
  367.           (accessor-miss-function gf dfun-info))
  368.      nil
  369.      dfun-info)))
  370.  
  371. ;;;
  372. ;;; std accessors same index dfun
  373. ;;;
  374. (declaim (ftype (function (T T T &optional T) (values function cache T))
  375.         make-one-index-accessor-dfun))
  376. (defun make-one-index-accessor-dfun (gf type index &optional cache)
  377.   (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
  378.      (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
  379.      (dfun-info (one-index-dfun-info type index cache)))
  380.     (declare (type cache cache))
  381.     (values
  382.      (funcall (get-dfun-constructor emit (consp index))
  383.           (cache-field cache) (cache-vector cache) 
  384.           (cache-mask cache) (cache-size cache)
  385.           index
  386.           (accessor-miss-function gf dfun-info))
  387.      cache
  388.      dfun-info)))
  389.  
  390. (declaim (ftype (function (T T T T) (values function cache T))
  391.         make-final-one-index-accessor-dfun))
  392. (defun make-final-one-index-accessor-dfun (gf type index table)
  393.   (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
  394.     (make-one-index-accessor-dfun gf type index cache)))                
  395.  
  396. (defun one-index-limit-fn (nlines)
  397.   (default-limit-fn nlines))
  398.  
  399.  
  400. (declaim (ftype (function (T T &optional T) (values function cache T))
  401.         make-n-n-accessor-dfun))
  402. (defun make-n-n-accessor-dfun (gf type &optional cache)
  403.   (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
  404.      (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
  405.      (dfun-info (n-n-dfun-info type cache)))
  406.     (declare (type cache cache))
  407.     (values
  408.      (funcall (get-dfun-constructor emit)
  409.           (cache-field cache) (cache-vector cache) 
  410.           (cache-mask cache) (cache-size cache)
  411.           (accessor-miss-function gf dfun-info))
  412.      cache
  413.      dfun-info)))
  414.  
  415. (declaim (ftype (function (T T T) (values function cache T))
  416.         make-final-n-n-accessor-dfun))
  417. (defun make-final-n-n-accessor-dfun (gf type table)
  418.   (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
  419.     (make-n-n-accessor-dfun gf type cache)))
  420.  
  421. (defun n-n-accessors-limit-fn (nlines)
  422.   (default-limit-fn nlines))
  423.  
  424. (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
  425.   (let ((cache
  426.           (or cache
  427.               (get-cache
  428.                  nkeys valuep limit-fn
  429.          (the index (+ (the index (hash-table-count table)) 3))))))
  430.     (maphash #'(lambda (classes value)
  431.          (setq cache (fill-cache cache
  432.                      (class-wrapper classes)
  433.                      value
  434.                      t)))
  435.          table)
  436.     cache))
  437.  
  438.  
  439. ;;;
  440. ;;;
  441. ;;;
  442.  
  443.  
  444. (defun make-checking-dfun (generic-function function &optional cache)
  445.   (unless cache
  446.     (when (some #'(lambda (method)
  447.             (method-closure-generator method))
  448.         (generic-function-methods generic-function))
  449.       (return-from make-checking-dfun (make-caching-dfun generic-function)))
  450.     (when (use-dispatch-dfun-p generic-function)
  451.       (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
  452.   (let* ((arg-info (gf-arg-info generic-function))
  453.      (metatypes (arg-info-metatypes arg-info))
  454.      (applyp (arg-info-applyp arg-info))
  455.      (nkeys (arg-info-nkeys arg-info)))
  456.     (declare (type boolean applyp) (type index nkeys))
  457.     (if (every #'(lambda (mt) (eq mt 't)) metatypes)
  458.     (values function nil (default-method-only-dfun-info))
  459.     (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
  460.            (dfun-info (checking-dfun-info function cache)))
  461.       (values
  462.        (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
  463.             (cache-field cache) (cache-vector cache) 
  464.             (cache-mask cache) (cache-size cache)
  465.             function 
  466.             #'(lambda (&rest args)
  467.             (declare (pcl-fast-call))
  468.             (checking-miss generic-function args dfun-info)))
  469.        cache
  470.        dfun-info)))))
  471.  
  472. (defun make-final-checking-dfun (generic-function function
  473.                           classes-list new-class)
  474.   (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
  475.     (if (every #'(lambda (mt) (eq mt 't)) metatypes)
  476.     (values function nil (default-method-only-dfun-info))
  477.     (let ((cache (make-final-ordinary-dfun-internal 
  478.               generic-function nil #'checking-limit-fn 
  479.               classes-list new-class)))
  480.       (make-checking-dfun generic-function function cache)))))
  481.  
  482. (defun checking-limit-fn (nlines)
  483.   (default-limit-fn nlines))
  484.  
  485.  
  486. ;;;
  487. ;;;
  488. ;;;
  489. (defun make-caching-dfun (generic-function &optional cache)
  490.   (unless cache
  491.     (when (use-constant-value-dfun-p generic-function)
  492.       (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
  493.     (when (use-dispatch-dfun-p generic-function)
  494.       (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
  495.   (let* ((arg-info (gf-arg-info generic-function))
  496.      (metatypes (arg-info-metatypes arg-info))
  497.      (applyp (arg-info-applyp arg-info))
  498.      (nkeys (arg-info-nkeys arg-info))
  499.      (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
  500.      (dfun-info (caching-dfun-info cache)))
  501.     (declare (type boolean applyp) (type index nkeys))
  502.     (values
  503.      (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
  504.           (cache-field cache) (cache-vector cache) 
  505.           (cache-mask cache) (cache-size cache)
  506.           #'(lambda (&rest args)
  507.           (declare (pcl-fast-call))
  508.           (caching-miss generic-function args dfun-info)))
  509.      cache
  510.      dfun-info)))
  511.  
  512. (defun make-final-caching-dfun (generic-function classes-list new-class)
  513.   (let ((cache (make-final-ordinary-dfun-internal 
  514.         generic-function t #'caching-limit-fn
  515.         classes-list new-class)))
  516.     (make-caching-dfun generic-function cache)))
  517.  
  518. (defun caching-limit-fn (nlines)
  519.   (default-limit-fn nlines))
  520.  
  521. (defun use-constant-value-dfun-p (gf)
  522.   (let ((methods (generic-function-methods gf))
  523.     (default '(unknown)))
  524.     (declare (type list methods))
  525.     (and (null (arg-info-applyp (gf-arg-info gf)))
  526.      (compute-applicable-methods-emf-std-p gf)
  527.      (< 1 (length methods))
  528.      (some #'(lambda (method)
  529.            (every #'(lambda (specl) (eq specl *the-class-t*))
  530.               (method-specializers method)))
  531.            methods)
  532.      (notany #'(lambda (method)
  533.              (or (some #'eql-specializer-p
  534.                    (method-specializers method))
  535.              (eq (plist-value method :constant-value default)
  536.                  default)))
  537.         methods))))
  538.  
  539. (defun make-constant-value-dfun (generic-function &optional cache)
  540.   (let* ((arg-info (gf-arg-info generic-function))
  541.      (metatypes (arg-info-metatypes arg-info))
  542.      (nkeys (arg-info-nkeys arg-info))
  543.      (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
  544.      (dfun-info (constant-value-dfun-info cache)))
  545.     (values
  546.      (funcall (get-dfun-constructor 'emit-constant-value metatypes)
  547.           (cache-field cache) (cache-vector cache) 
  548.           (cache-mask cache) (cache-size cache)
  549.           #'(lambda (&rest args)
  550.           (declare (pcl-fast-call))
  551.           (constant-value-miss generic-function args dfun-info)))
  552.      cache
  553.      dfun-info)))
  554.  
  555. (defun make-final-constant-value-dfun (generic-function classes-list new-class)
  556.   (let ((cache (make-final-ordinary-dfun-internal 
  557.         generic-function :constant-value #'caching-limit-fn
  558.         classes-list new-class)))
  559.     (make-constant-value-dfun generic-function cache)))
  560.  
  561. (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
  562.                       classes-list new-class)
  563.   (let* ((arg-info (gf-arg-info generic-function))
  564.      (nkeys (arg-info-nkeys arg-info))
  565.      (new-class (and new-class
  566.              (equal (type-of (gf-dfun-info generic-function))
  567.                 (cond ((eq valuep t) 'caching)
  568.                       ((eq valuep :constant-value) 'constant-value)
  569.                       ((null valuep) 'checking)))
  570.              new-class))
  571.      (cache (if new-class
  572.             (copy-cache (gf-dfun-cache generic-function))
  573.             (get-cache nkeys (not (null valuep)) limit-fn 4))))
  574.       (declare (type index nkeys))
  575.       (make-emf-cache generic-function valuep cache classes-list new-class)))
  576.  
  577. (defun use-caching-dfun-p (gf)
  578.   (some #'method-function-for-caching-p (generic-function-methods gf)))
  579.  
  580. (defun use-dispatch-dfun-p (gf)
  581.   (unless (use-caching-dfun-p gf)
  582.     (let* ((methods (generic-function-methods gf))
  583.        (arg-info (gf-arg-info gf))
  584.        (mt (arg-info-metatypes arg-info))
  585.        (nreq (length mt)))
  586.       (declare (type list methods mt) (type index nreq))
  587.       ;;Is there a position at which every specializer is eql or non-standard?
  588.       (dotimes (i nreq nil)
  589.     (when (not (eq 't (nth i mt)))
  590.       (let ((some-std-class-specl-p nil))
  591.         (dolist (method methods)
  592.           (let ((specl (nth i (method-specializers method))))
  593.         (when (and (not (eql-specializer-p specl))
  594.                            (class-standard-p (specializer-class specl)))
  595.           (setq some-std-class-specl-p t))))
  596.         (unless some-std-class-specl-p
  597.           (return-from use-dispatch-dfun-p t))))))))
  598.  
  599. (defvar *lazy-dispatch-dfun-compute-p* t)
  600. (defvar *lazy-dfun-compute-p* nil)
  601.  
  602. (defun make-dispatch-dfun (gf)
  603.   (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
  604.  
  605. (defun make-final-dispatch-dfun (gf)
  606.   (if *lazy-dispatch-dfun-compute-p*
  607.       (values (let ((*lazy-dfun-compute-p* t))
  608.         (make-initial-dfun gf))
  609.           nil (initial-dispatch-dfun-info))
  610.       (make-dispatch-dfun gf)))
  611.  
  612. (defun before-precompile-random-code-segments ()
  613.   (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
  614.     (dfun-update gf #'make-dispatch-dfun)))
  615.  
  616. (defvar *dfun-miss-gfs-on-stack* ())
  617.  
  618. (defmacro dfun-miss ((gf args wrappers invalidp nfunction 
  619.               &optional type index caching-p applicable)
  620.              &body body)
  621.   (unless applicable (setq applicable (gensym)))
  622.   `(multiple-value-bind (,wrappers ,invalidp ,nfunction ,applicable 
  623.                    ,@(when type `(,type ,index)))
  624.        (cache-miss-values ,gf ,args ',(cond (type 'accessor)
  625.                         (caching-p 'caching)
  626.                         (t 'checking)))
  627.      (declare (type boolean ,invalidp))
  628.      (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
  629.        (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
  630.      ,@body))
  631.      (method-function-apply ,nfunction ,args)))
  632.  
  633. ;;;
  634. ;;; The dynamically adaptive method lookup algorithm is implemented is
  635. ;;; implemented as a kind of state machine.  The kinds of discriminating
  636. ;;; function is the state, the various kinds of reasons for a cache miss
  637. ;;; are the state transitions.
  638. ;;;
  639. ;;; The code which implements the transitions is all in the miss handlers
  640. ;;; for each kind of dfun.  Those appear here.
  641. ;;;
  642. ;;; Note that within the states that cache, there are dfun updates which
  643. ;;; simply select a new cache or cache field.  Those are not considered
  644. ;;; as state transitions.
  645. ;;; 
  646. (defun make-initial-dfun (gf)
  647.   (if (or *lazy-dfun-compute-p* (not (compute-applicable-methods-emf-std-p gf)))
  648.       #'(lambda (&rest args)
  649.       #+Genera (declare (dbg:invisible-frame :pcl-internals))
  650.       (initial-dfun args gf))
  651.       (make-final-dfun gf (precompute-effective-methods gf t))))
  652.  
  653. (defun initial-dfun (args generic-function)
  654.   #+Genera (declare (dbg:invisible-frame :pcl-internals))
  655.   (dfun-miss (generic-function args wrappers invalidp nfunction ntype nindex)
  656.     (cond (invalidp)
  657.       ((and ntype nindex)
  658.        (dfun-update generic-function
  659.             #'make-one-class-accessor-dfun ntype wrappers nindex))
  660.       (t
  661.        (dfun-update generic-function #'make-checking-dfun
  662.             ;; nfunction is suitable only for caching, have to do this:
  663.             (multiple-value-bind (w i function)
  664.                 (cache-miss-values generic-function args 'checking)
  665.               (declare (ignore w i))
  666.               function))))))
  667.  
  668. (defun make-final-dfun (gf &optional classes-list)
  669.   (multiple-value-bind (dfun cache info)
  670.       (make-final-dfun-internal gf classes-list)
  671.     (set-dfun gf dfun cache info)))
  672.  
  673. (defun make-final-dfun-internal (gf &optional classes-list)
  674.   (let ((methods (generic-function-methods gf)) type
  675.     (new-class *new-class*) (*new-class* nil))
  676.     (cond ((null methods)
  677.        (values
  678.         #'(lambda (&rest args)
  679.         (apply #'no-applicable-method gf args))
  680.         nil
  681.         (no-methods-dfun-info)))
  682.       ((setq type (cond ((every #'standard-reader-method-p methods)
  683.                  'reader)
  684.                 ((every #'standard-writer-method-p methods)
  685.                  'writer)))
  686.        (with-eq-hash-table (table)
  687.          (multiple-value-bind (table all-index first second size no-class-slots-p)
  688.          (make-accessor-table gf type table)
  689.                (declare (type boolean no-class-slots-p))
  690.            (if table
  691.            (cond ((= (the index size) 1)
  692.               (let ((w (class-wrapper first)))
  693.                 (make-one-class-accessor-dfun gf type w all-index)))
  694.              ((and (= (the index size) 2)
  695.                                (or (integerp all-index) (consp all-index)))
  696.               (let ((w0 (class-wrapper first))
  697.                 (w1 (class-wrapper second)))
  698.                 (make-two-class-accessor-dfun gf type w0 w1 all-index)))
  699.              ((or (integerp all-index) (consp all-index))
  700.               (make-final-one-index-accessor-dfun 
  701.                gf type all-index table))
  702.              (no-class-slots-p
  703.               (make-final-n-n-accessor-dfun gf type table))
  704.              (t
  705.               (make-final-caching-dfun gf classes-list new-class)))
  706.            (make-final-caching-dfun gf classes-list new-class)))))
  707.       ((use-constant-value-dfun-p gf)
  708.        (make-final-constant-value-dfun gf classes-list new-class))
  709.       ((use-dispatch-dfun-p gf)
  710.        (make-final-dispatch-dfun gf))
  711.       ((let ((specls (method-specializers (car methods))))
  712.          (and (every #'(lambda (method)
  713.                  (and (equal specls (method-specializers method))))
  714.              methods)
  715.           (not (use-caching-dfun-p gf))))
  716.        (let ((function (get-secondary-dispatch-function gf methods nil)))
  717.          (make-final-checking-dfun gf function classes-list new-class)))
  718.       (t
  719.        (make-final-caching-dfun gf classes-list new-class)))))
  720.  
  721. (defun accessor-miss (gf new object dfun-info)
  722.   (let* ((ostate (type-of dfun-info))
  723.      (otype (dfun-info-accessor-type dfun-info))
  724.      oindex ow0 ow1 cache
  725.      (args (ecase otype            ;The congruence rules assure
  726.         (reader (list object))        ;us that this is safe despite
  727.         (writer (list new object)))))    ;not knowing the new type yet.
  728.     (dfun-miss (gf args wrappers invalidp nfunction ntype nindex)
  729.       ;;
  730.       ;; The following lexical functions change the state of the
  731.       ;; dfun to that which is their name.  They accept arguments
  732.       ;; which are the parameters of the new state, and get other
  733.       ;; information from the lexical variables bound above.
  734.       ;; 
  735.       (flet ((two-class (index w0 w1)
  736.            (when (zerop (the index (random 2))) (psetf w0 w1 w1 w0))
  737.            (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index))
  738.          (one-index (index &optional cache)
  739.            (dfun-update gf #'make-one-index-accessor-dfun ntype index cache))
  740.          (n-n (&optional cache)
  741.            (if (consp nindex)
  742.            (dfun-update gf #'make-checking-dfun nfunction)
  743.            (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
  744.          (caching () ; because cached accessor emfs are much faster for accessors
  745.            (dfun-update gf #'make-caching-dfun))
  746.          ;;
  747.          (do-fill (update-fn)
  748.            (let ((ncache (fill-cache cache wrappers nindex)))
  749.          (unless (eq ncache cache)
  750.            (funcall-function update-fn ncache)))))
  751.     (cond ((null ntype)
  752.            (caching))
  753.           ((or invalidp
  754.            (null nindex)))
  755.           ((not (or (std-instance-p object)
  756.             (fsc-instance-p object)
  757.                         #+pcl-user-instances
  758.                         (user-instance-p object)))
  759.            (caching))
  760.           ((or (neq ntype otype) (listp wrappers))
  761.            (caching))
  762.           (t
  763.            (ecase ostate
  764.          (one-class
  765.           (setq oindex (dfun-info-index dfun-info))
  766.           (setq ow0 (dfun-info-wrapper0 dfun-info))
  767.           (unless (eq ow0 wrappers)
  768.             (if (eql nindex oindex)
  769.             (two-class nindex ow0 wrappers)
  770.             (n-n))))
  771.          (two-class
  772.           (setq oindex (dfun-info-index dfun-info))
  773.           (setq ow0 (dfun-info-wrapper0 dfun-info))
  774.           (setq ow1 (dfun-info-wrapper1 dfun-info))
  775.           (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
  776.             (if (eql nindex oindex)
  777.             (one-index nindex)
  778.             (n-n))))
  779.          (one-index
  780.           (setq oindex (dfun-info-index dfun-info))
  781.           (setq cache (dfun-info-cache dfun-info))
  782.           (if (eql nindex oindex)
  783.               (do-fill #'(lambda (ncache)
  784.                    (one-index nindex ncache)))
  785.               (n-n)))
  786.          (n-n
  787.           (setq cache (dfun-info-cache dfun-info))
  788.           (if (consp nindex)
  789.               (caching)
  790.               (do-fill #'n-n))))))))))
  791.  
  792. (defun checking-miss (generic-function args dfun-info)
  793.   (let ((ofunction (dfun-info-function dfun-info))
  794.     (cache (dfun-info-cache dfun-info)))
  795.     (dfun-miss (generic-function args wrappers invalidp nfunction)
  796.       (cond (invalidp)
  797.         ((eq ofunction nfunction)
  798.          (let ((ncache (fill-cache cache wrappers nil)))
  799.            (unless (eq ncache cache)
  800.          (dfun-update generic-function #'make-checking-dfun 
  801.                   nfunction ncache))))
  802.         (t
  803.          (dfun-update generic-function #'make-caching-dfun))))))
  804.  
  805. (defun caching-miss (generic-function args dfun-info)
  806.   (let ((ocache (dfun-info-cache dfun-info)))
  807.     (dfun-miss (generic-function args wrappers invalidp function nil nil t)
  808.       (cond (invalidp)
  809.         (t
  810.          (let ((ncache (fill-cache ocache wrappers function)))
  811.            (unless (eq ncache ocache)
  812.          (dfun-update generic-function 
  813.                   #'make-caching-dfun ncache))))))))
  814.  
  815. (defun constant-value-miss (generic-function args dfun-info)
  816.   (let ((ocache (dfun-info-cache dfun-info)))
  817.     (dfun-miss (generic-function args wrappers invalidp function nil nil t)
  818.       (cond (invalidp)
  819.         (t
  820.          (let* ((value (method-constant-value (method-function-method function)))
  821.             (ncache (fill-cache ocache wrappers value)))
  822.            (unless (eq ncache ocache)
  823.          (dfun-update generic-function
  824.                   #'make-constant-value-dfun ncache))))))))
  825.  
  826.  
  827.  
  828. (defvar dfun-count nil)
  829. (defvar dfun-list nil)
  830. (defvar *minimum-cache-size-to-list*)
  831.  
  832. (defun list-dfun (gf)
  833.   (let* ((sym (type-of (gf-dfun-info gf)))
  834.      (a (assq sym dfun-list)))
  835.     (unless a
  836.       (push (setq a (list sym)) dfun-list))
  837.     (push (generic-function-name gf) (cdr a))))
  838.  
  839. (defun list-all-dfuns ()
  840.   (setq dfun-list nil)
  841.   (map-all-generic-functions #'list-dfun)
  842.   dfun-list)
  843.  
  844. (defun list-large-cache (gf)
  845.   (let* ((sym (type-of (gf-dfun-info gf)))
  846.      (cache (gf-dfun-cache gf)))
  847.     (when cache
  848.       (let ((size (cache-size cache)))
  849.         (declare (type index size))
  850.     (when (>= size (the index *minimum-cache-size-to-list*))
  851.       (let ((a (assoc size dfun-list)))
  852.         (unless a
  853.           (push (setq a (list size)) dfun-list))
  854.         (push (let ((name (generic-function-name gf)))
  855.             (if (eq sym 'caching) name (list name sym)))
  856.           (cdr a))))))))
  857.  
  858. (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130))
  859.   (setq dfun-list nil)
  860.   (map-all-generic-functions #'list-large-cache)
  861.   (setq dfun-list (sort dfun-list #'< :key #'car))
  862.   (mapc #'print dfun-list)
  863.   (values))
  864.  
  865.  
  866. (defun count-dfun (gf)
  867.   (let* ((sym (type-of (gf-dfun-info gf)))
  868.      (cache (gf-dfun-cache gf))
  869.      (a (assq sym dfun-count)))
  870.     (unless a
  871.       (push (setq a (list sym 0 nil)) dfun-count))
  872.     (setf (cadr a) (the index (1+ (the index (cadr a)))))
  873.     (when cache
  874.       (let* ((size (cache-size cache))
  875.          (b (assoc size (third a))))
  876.     (unless b 
  877.       (push (setq b (cons size 0)) (third a)))
  878.         (setf (cdr b) (the index (1+ (the index (cdr b)))))))))
  879.  
  880. (defun count-all-dfuns ()
  881.   (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil))
  882.                '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY
  883.                  ONE-INDEX N-N CHECKING CACHING 
  884.                  DISPATCH)))
  885.   (map-all-generic-functions #'count-dfun)
  886.   (mapc #'(lambda (type+count+sizes)
  887.         (setf (third type+count+sizes)
  888.           (sort (third type+count+sizes) #'< :key #'car)))
  889.     dfun-count)
  890.   (mapc #'(lambda (type+count+sizes)
  891.         (format t "~&There are ~4d dfuns of type ~s"
  892.             (cadr type+count+sizes) (car type+count+sizes))
  893.         (format t "~%   ~S~%" (caddr type+count+sizes)))
  894.     dfun-count)
  895.   (values))
  896.  
  897. (defun gfs-of-type (type)
  898.   (unless (consp type) (setq type (list type)))
  899.   (let ((gf-list nil))
  900.     (map-all-generic-functions #'(lambda (gf)
  901.                    (when (memq (type-of (gf-dfun-info gf)) type)
  902.                      (push gf gf-list))))
  903.     gf-list))
  904.